perm filename S3X.F4[M11,LCS] blob
sn#418034 filedate 1979-02-10 generic text, type T, neo UTF8
00100 C ********** S3X.F4 ******* SEE RUN.CMD, SCORE.CMD --
00200 C AND, IF DESIRED, A SUBROUTINE WITH THE FOLLOWING HEADING:
00300 C SUBROUTINE SUBR
00400 C COMMON /P/P(1) /PL/IPL(1) /INS/ RINST(27),BG(60)
00500 C COMMON INUM,IPAR /KNT/KNT(27),BT,IREST,DF /DUR/DUR(27)
00600 C INUM=INST# IPAR=PARAM#
00700 C BT=BASIC TIME P1 WHEN SUBROUTINE IS CALLED
00800 C IF IREST IS <0, THAT NOTE WILL BE A REST.
00900 C RINST=INST. NAME, BG=INSTS' BEGIN TIMES.
01000 C NOTE #S IN SUBROUTINE: (1-108) C4=49 FS4=55 B4=60 C5=61 ETC.
01100 C F0=200 F99=299 (LIMIT IS F0-F99!) 'R'(REST)=199
01200
01300 SUBROUTINE RUNIT
01400 INTEGER PL,PL4,COPYL
01500 C11 DOUBLE PRECISION IF0,IF00,IVX,IV
01600 COMMON /PCIP/ PCH(27,33) /IPT/IPT(27,32) /JPREC/JPREC
01700 C 2ND NUM IN IPT=NUMP+2. (NUMPY)
01800 C PL SHOULD HAVE ABOUT NUMP+17
01900 COMMON/P/P(30) /PL/PL(47) /NUMP/NUMP /NDEV/NDEV
02000 1 /COPY/COPY(30) /COPYL/COPYL(30)
02100 CKL COMMON/P/P(1) /PL/PL(1) /COPY/NUMP,COPY(1)/COPYL/COPYL(1)
02200
02300 COMMON /Q/ BNW(200),NWZ /INS/RINST(27),BG(60) /TYP/JOUT,LN
02400 1 /ROFF/ROFF(27),RDEV(27),P1(27)
02500 1 /VV/LIMIT,V(1) /A/NP(27),XT(27),FRM(80),INVIS(27)
02600 C JPT MUST BE .LE.27*NUMPY !!
02700 DIMENSION IV(1),IT(30),JPT(837),NCNT(27,32)
02800 1,COFF1(27),COFF2(27),RREST(27),RNP(27),ISC(12),IOC(9)
02900 C WITH VX AT 70 AND FRM AT 80 OK FOR ONLY
03000 C 40 LIT CHARS + 30 PARAMS PER INST.
03100 C 60 BG TIMES AVAILABLE. FOR INSTS AND INSERTS AND EDITS.
03200 COMMON J,L /DUR/DUR(27) /KNT/KNT(27),BT,IREST,DF
03300 1/E/IQ(27),KL,X,ZPAR,KA,LK,NNUM,JJ,JA,ISUB,NFLG
03400 1 ,VX(70),RAMP,K,KN,M,ML,CODE
03500 COMMON/B/MOT,PR,T5,NINS,I,RA,KZY,NWX,INONLY,MX,
03600 1 Y,Z,FNAME,MZ,N,IDALL,JC,JG,RB,IJ,IX,BW,NL,RC,W,
03700 1 ZZ,CHN,YY
03800 1 /D/TF,AMPFAC,OP1,DURX,IXIN,FLNM
03900 1 /C/T,NWZZ,IT3,T6,NW,TDUR,A,T2,T4,BY,
04000 1 KODE,NPAR,LP,TBG,AC,NPA,IBX,IDF,PM,NM,PAR,PX2,T1,RD,
04100 1 VIJ2
04200 C /C/=26
04300 EQUIVALENCE (PP1,P(1)),(P(2),P2),(P(3),P3),(P(4),P4),
04400 1 (VX1,VX(1)),(PL4,PL(4)),(IPT,JPT),(IVX,RVX)
04500 1 ,(VX2,VX(2)),(VX3,VX(3)),(NCNT,PCH),(VX4,VX(4))
04600 1 ,(VX5,VX(5)),(V,IV)
04700 CC DATA SCAL/'C/8','CS/8','D/8','DS/8','E/8','F/8','FS/8','G/8',
04800 CC 1 'GS/8','A/8','AS/8','B/8','C/4','CS/4','D/4','DS/4','E/4',
04900 CC 1 'F/4','FS/4','G/4','GS/4','A/4','AS/4','B/4','C/2','CS/2',
05000 CC 1 'D/2','DS/2','E/2','F/2','FS/2','G/2','GS/2','A/2','AS/2',
05100 CC 1 'B/2','C','CS','D','DS','E','F','FS','G','GS','A','AS',
05200 CC 1 'B','C*2','CS*2','D*2','DS*2','E*2','F*2','FS*2','G*2',
05300 CC 1 'GS*2','A*2','AS*2','B*2','C*4','CS*4','D*4','DS*4','E*4',
05400 CC 1 'F*4','FS*4','G*4','GS*4','A*4','AS*4','B*4','C*8','CS*8',
05500 CC 1 'D*8','DS*8','E*8','F*8','FS*8','G*8','GS*8','A*8','AS*8',
05600 CC 1 'B*8','R','F1','F2','F3','F4','F5','F6','F7','F8','F9',
05700 CC 1 'F10','F11','F12','F13','F14','F15','END'/,I1X/'1X'/,
05710 DATA MDEV/1/
05720 C ********* MDEV IS A DSK OUTPUT DEVICE NUMBER.
05800 DATA B1X/'1X'/,FRM1/' (1XA'/,FRM2/'4, '/,COMMA/4H',',/,
05900 1 BA4/'1XA5'/,BA1/'A1, '/,IF0/' F0'/,IF10/' F00'/,
06000 1 BDOL/'$)'/,B2A/' 2F9.'/, NPRLN/8/,
06100 1 B2B/'3, '/,B9/'F9.1'/,B8/'F8.3'/,BPRN/') '/,BLA/' '/
06200 1, BCOM/', '/,RNDOFF/1000.0/,IBLA/' '/,PLAY/'PLAY'/,ISEMI/';'/
06300 C********************CHANGE BA4 TO '1XA4' ************************
06400 C******** ALSO FRM1 TO '(1XA' ---- ETC.!!!!!!!
06450 C NPRLN IS NUMBER OF PARAMS TO BE PRINTED PER LINE.
06500 DATA ISC/' C ',' CS ',' D ',' DS ',' E ',' F ',
06600 1 ' FS ',' G ',' GS ',' A ',' AS ',' B '/,
06700 1 IOC/3872, 3888,3880,3876, 0, 2596,2600,2604, 2592/
06800 C FUNNY NUMS IN IOC = /0, /8, /4, /2, IBLA, *2, *4, *8, *0 (0=16 FOR MULT OR DIV.)
06900 C THESE APPEAR AS LAST 3 CHARS. WHEN ADDED TO ELEMENTS OF ISC ARRAY.
07000 EQUIVALENCE (FRM1,FRM(1)),(FRM2,FRM(2)),(FRM3,FRM(3)),
07100 1 (FRM4,FRM(4))
07200
07300 C***** XXXX MUS10 NOW FIXED XXXXX IF(ISAM.GE.0)RNDOFF=100.0
07400 C USE DIFF. ROUND-OFF FOR MUS10 (100) (SAMSWITCH ≥0)
07500 IF(JPREC.GE.0)GO TO 9350
07600 C NOW FOUND 'PRECEDE' MATERIAL TO TYPE OR WRITE ON DSK.
07700 9351 READ(21,END=9350)K,(XT(J),J=1,K)
07800 IF(MZ)WRITE(JOUT,9352)(XT(J),J=1,K)
07900 IF(MX)WRITE(MDEV,9353)(XT(J),J=1,K)
08000 GO TO 9351
08100 9352 FORMAT(1X15A5)
08200 9353 FORMAT(15A5)
08300 9350 ITOT=1
08400 NUMPX=NUMP+1
08500 NUMPY=NUMP+2
08600 PR=0
08700 DO 9337 K=1,27
08800 KNT(K)=0
08900 RDEV(K)=0
09000 IPT(K,1)=0
09100 COFF1(K)=0
09200 9337 RREST(K)=0
09300 C ZEROS NAME CHANGE, CUTOFF AND RAND REST STORAGE
09400 2337 T=0
09500 DO 1107 K=1,NUMP
09600 1107 PL(K)=1
09700 C 2/74--WAS AT 17300/1 SETS DEFAULT OUTPUT MODE TO 1.
09800 WRITE(JOUT,902)
09900 C WRITES A BLANK LINE (IF 'SOS' WAS HERE)
10000 NWZZ=0
10100 RAMP=0
10200 IT3=0
10300 K=1
10400 IX=0
10500 BG(NINS+1)=19999.
10600 4337 IF(V(I-1).EQ.-9900.-BY)I=I-1
10700 V(I)=-19899.
10800 PP1=0
10900 T6=10000.
11000 DO 2118 K=1,NINS
11100 ROFF(K)=0
11200 C********* FEB 17,71
11300 M=NP(K)
11400 IT(K)=0
11500 IPT(K,NUMPX)=0
11600 NCNT(K,NUMPX)=1
11700 DO 2118 L=1,M
11800 NCNT(K,L)=1
11900 2118 IPT(K,L)=0
12000 DO 5013 K=1,IXIN
12100 5013 X=RAN(X)
12200 C NOW USES EXTENSION .DAT WHEN WRITING ON DSK (DEV. 1 ONLY!)
12300 NW=1
12400 NWX=0
12500 TDUR=0
12600 A=0
12700 T2=1.
12800 T4=1.
12900 T5=0
13000 J=1
13100 IF(MX.NE.5)GO TO 1002
13200 CKL IF(MX.NE.5)GO TO 40021
13300 K=4
13400 10023 N=AMOD(V(K),100.0)/-11.
13500 C AMOD NEEDED BECAUSE CODE # MAY HAVE -100 FOR DF OR -200 FOR SUBR.
13600 IF(N.EQ.2)GO TO 77
13700 IF(N.EQ.3)GO TO 77
13800 IF(N.NE.4)GO TO 10021
13900 C TYPES OUT LIST OF ITEMS IN CODE NUMS -2n, -3n, -4n.
14000 77 IF(V(K-2).LT.10000.)GO TO 10021
14100 C FINDS A PARAM. NUM.
14200 J=V(K+1)
14300 KA=K+ABS(V(K-1))
14400 C FOR UPDATE OF POINTER.
14500 IF(J.EQ.1)GO TO 10024
14600 177 N=V(K-2)
14700 L=N/10000
14800 M=N-L*10000
14900 IF(V(KA-2).EQ.-10000.)J=J-1
15000 C DON'T INCLUDE 'FINE' AS AN ITEM.
15100 WRITE(NDEV,10022)RINST(L),M,J
15200 10024 K=KA
15300 10021 K=K+1
15400 IF(K.LT.I)GO TO 10023
15500 CKL40021 IF(MZ.NE.-6)GO TO 1002
15600 CKL N=1
15700 CKL40022 K=N+1
15800 CKL IF(N.GT.I)CALL EXIT
15900 CKL X=V(N)
16000 CKL IF(X.EQ.-199.)GO TO 40024
16100 CKL IF(X.EQ.-99.)GO TO 40024
16200 CKL IF(X.GE.0)GO TO 40023
16300 CKL TYPE 4002,X
16400 CKL N=N+1
16500 CKL GO TO 40022
16600 CKL40024 J=N+1
16700 CKL GO TO 40025
16800 C FOR 'SECTIONS'
16900 CKL40023 J=ABS(V(K))+K-1
17000 CKL40025 TYPE 4002,(V(K),K=N,J)
17100 CKL N=J+1
17200 CKL GO TO 40022
17300 10022 FORMAT(1XA4,' P',I2,' HAS ',I3,' ITEMS.')
17400 CKL4002 FORMAT(10F12.3)
17500 1002 IF(IDALL)GO TO 600
17600 X=DUR(IDALL)
17700 DO 2002 K=1,NINS
17800 2002 IF(DUR(K))DUR(K)=X
17900
00100 C ***** SORTER *************************
00200 C ******* OUTPUT LOOP FROM HERE ON ********
00300 600 IL=0
00400 C********** BELOW IS FOR 'SECTIONS'
00500 KODE=0
00600 NWX=NWX+1
00700 Y=BNW(NW)
00800 723 IL=IL+1
00900 3723 Z=V(IL)
01000 IF(Z.EQ.-19899.)GO TO 732
01100 IF(Z.NE.-9900.-Y)GO TO 723
01200 C********** BELOW IS FOR 'SECTIONS'
01300 IF(V(IL-2).EQ.-199.)KODE=IV(IL-1)
01400 2723 IL=IL+1
01500 729 K=IL+2
01600 MOT=V(IL+1)
01700 RD=V(K)
01800 IF(RD.EQ.-67.)GO TO 3726
01900 RB=V(IL)
02000 C************ DOWN TO 4150 IS FOR 'SECTIONS'
02100 IF(RB.NE.-99.)GO TO 4150
02200 KODE=IV(K-1)
02300 2160 IF(KODE.EQ.0)GO TO 723
02400 IF(MZ)WRITE(JOUT,9150),KODE
02500 KL=Y/10000.
02600 RB=Y+KL*10000.
02700
02800 DO 5150 KL=1,I
02900 IF(V(KL).NE.-199.)GO TO 5150
03000 IF(IV(KL+1).NE.KODE)GO TO 5150
03100 IV(K-1)=0
03200 C WHEN 'PLAY' HAS BEEN FOUND, INDENTIFIER CHNGED TO 0
03300 RD=V(KL+2)+9900.
03400 DO 6150 L=KL+2,I
03500 M=V(L)/(-9900.)
03600 IF(M.NE.1)GO TO 6150
03700 RA=RB+RD-V(L)-9900.
03800 V(L)=-9900.-RA
03900 C UPDATES BG TIMES INSIDE SECTION.
04000 CALL BGSORT(RA)
04100 C UPDATES LIST OF CHANGE TIMES.
04200 6150 IF(V(L).EQ.-299.)GO TO 160
04300 5150 CONTINUE
04400
04500 160 IL=1
04600 GO TO 3723
04700 C*********** ABOVE IS FOR 'SECTION' REPEATS
04800 4150 LK=RB/10000.+.2
04900 IF(LK.GE.98)GO TO 7700
05000 LP=RB-LK*10000
05100 C LK=INST # LP=PARAM #
05200 LN=IPT(LK,LP)
05300 IPT(LK,LP)=IL+2
05400 IF(RD.EQ.-66.)GO TO 726
05500 CCCCCCC 'K' IS USED AS POINTER AT 6700-DON'T WIPE IT OUT! K=RD/-10.
05600 CCCCCCC IF(K.EQ.5)GO TO 1726
05700 IF(IFIX(RD/-10.).EQ.5)GO TO 1726
05800 C -59=MOVX, -55=MOV.
05900 IF(RD.EQ.-23)GO TO 6700
06000
06100 2727 ML=IPT(LK,LP)
06200 IF(MOT.GT.0)GO TO 3727
06300 C USE NEG WDCNT FOR 'ALL'
06400 DO 4727 KL=LK+1,NINS
06500 IF(NP(KL).GE.LP)GO TO 277
06600 IF(LP.LT.NUMPX)NP(KL)=LP
06700 277 IPT(KL,LP)=-(LK+(LP-1)*KZY)
06800 NCNT(KL,LP)=10000
06900 4727 IF(DUR(KL))DUR(KL)=10000.
07000 C ASSUMES THAT DURATIONS ARE SET IN 'NOTES'.
07100 C AFTER 'ALL' IS USED ONCE IT WORKS LIKE DUPL OR REP.
07200 GO TO 727
07300 C 'MOVE' WITH 'ALL' KEEPS ORIGINAL BG TIME DATA REGARDLESS OF LATER BG TIMES.
07400 3727 IF(LN.LE.0)GO TO 727
07500 IF(V(IL).NE.V(LN-1))GO TO 727
07600 DO 1727 L=1,NINS
07700 DO 1727 KL=1,NP(L)
07800 IF(LN.NE.IPT(L,KL))GO TO 1727
07900 NCNT(L,KL)=10000
08000 IPT(L,KL)=ML
08100 C RESETS POINTERS FOR DUPL AND REP INSTS.
08200 1727 CONTINUE
08300
08400 727 NCNT(LK,LP)=10000
08500 2150 IF(MOT)MOT=-MOT
08600 IL=IL+MOT+1
08700 3150 IF(V(IL))GO TO 3723
08800 GO TO 729
08900 726 RB=V(IL+3)
09000 K=RB/10000.
09100 L=RB-K*10000
09200 IPT(LK,LP)=-(K+(L-1)*KZY)
09300 GO TO 2727
09400 3726 LK=V(IL)
09500 M=V(K+1)
09600 KL=NP(M)
09700 DO 4726 L=1,KL
09800 IPT(LK,L)=IPT(M,L)
09900 IF(IPT(M,L).NE.0)NCNT(LK,L)=10000
10000 4726 CONTINUE
10100 C NUMPX =31 (NUMP+1) NEXT DUPLS. RAN. RESTS.
10200 IPT(LK,NUMPX)=IPT(M,NUMPX)
10300 K=0
10400 GO TO 2150
10500 C ABOVE IS FOR DUPLICATION ROUTINE NEXT ADJUSTS TIMES FOR 'RTAP'
10600 6700 KL=IL+V(IL+1)+1.3
10700 RC=V(K-2)
10800 1770 IF(V(KL))GO TO 700
10900 2700 KL=KL+V(KL+1)+1.3
11000 GO TO 1770
11100 700 KL=KL+1
11200 IF(Z.NE.V(KL-1))GO TO 2700
11300 IF(V(KL).NE.RC)GO TO 2700
11400 KL=KL+3
11500 KN=IL+3
11600 LN=V(KN)+.3
11700 DO 3700 L=1,LN,2
11800 RA=V(L+KN)
11900 KA=V(L+KN+1)+.3
12000 RB=0
12100 DO 4700 LP=1,KA
12200 4700 RB=RB+V(KL+LP)
12300 DO 5700 LP=1,KA
12400 5700 V(KL+LP)=V(KL+LP)/RB*RA
12500 V(KL+KA)=V(KL+KA)+.00030
12600 C NEEDS ERROR TRAP HERE FOR SITUATION WHEN THERE AREN'T ENOUGH TAPS.
12700 3700 KL=KL+KA
12800 GO TO 2150
12900
13000 C BELOW FOR 'TEMPO' SETUP
13100 7700 T2=V(IL+4)
13200 T1=V(IL+3)
13300 TBG=Y
13400 TDUR=V(IL+2)
13500 CALL SQYY(AC,T1,T2,TDUR)
13600 8700 IF(TDUR.EQ.0)TDUR=10000.
13700 T5=1.
13800 T6=TBG+TDUR
13900 IT3=1.
14000 IF(LK.EQ.98)IT3=IL+2
14100 T4=1.
14200 GO TO 2150
14300 C*************** ANY WDCNTS DOWN FROM HERE. *********
14400 C NEXT ADJUSTS 'MOVE' TIMES IF BG IS AT A NOTE NUMBER.
14500 1726 IF(V(IL-1).GT.-19000.)GO TO 2727
14600 RA=BT
14700 K=IL-1
14800 2726 RZ=V(K)
14900 V(K)=-9900.-RA
15000 ISUB=-1
15100 L=K+5
15200 K=K+V(K+2)+2
15300 IF(V(K).GT.-19000.)GO TO 2727
15400 IF(V(K+1).NE.V(IL))GO TO 2727
15500
15600 IF(V(K).NE.RZ-V(L-1))GO TO 2727
15700 RA=RA+V(L-1)
15800 CALL BGSORT(RA)
15900 GO TO 2726
16000 C CONVERTS BG TIME OF NOTE NUM TO REAL TIME. DOESN'T WORK WITH -66!
16100 C NOW WE BEGIN ON!! NOTE NUM. NOT AFTER NOTE NUM.
16200 732 DO 2606 K=NW,NWZ
16300 2606 BNW(K)=BNW(K+1)
16400 NWZ=NWZ-1
16500 IF(NWZ.EQ.0)GO TO 2111
16600 IF(NWZZ.EQ.1)GO TO 5111
16700 NWZZ=1
16800 IF(NWZ.EQ.1)GO TO 1111
16900 DO 3111 K=1,NWZ
17000 IF(BNW(K).LT.1000.)GO TO 3111
17100 X=BNW(NWZZ)
17200 BNW(NWZZ)=BNW(K)
17300 BNW(K)=X
17400 NWZZ=NWZZ+1
17500 3111 CONTINUE
17600 5111 IF(NWZZ.EQ.NWZ)GO TO 1111
17700 L=NWZZ+1
17800 X=BNW(NWZZ)
17900 DO 4111 K=L,NWZ
18000 IF(BNW(K).GT.X)GO TO 4111
18100 RA=BNW(K)
18200 BNW(K)=X
18300 X=RA
18400 4111 CONTINUE
18500 BNW(NWZZ)=X
18600 GO TO 1111
18700 111 FORMAT(1XA4,'.DAT',12X,'EDIT FILE NAME=',A4,8X,
18800 1'STORAGE=',I5,'/',I5,/' TEMPO FACTOR=',F6.2/)
18900 1023 FORMAT(/' < ',A4,'.DAT -- RANDOM NUMBER=',I6/1X2A4)
19000 C********** BELOW IS FOR 'SECTIONS'
19100 9150 FORMAT(/3X'******* SECTION ',A1)
19200 2111 NWZ=-1
19300 C ABOVE ORDERS BNW DATA TO SAVE TIME AT 1108 ON PG5.
19400 1111 IF(MZ.EQ.0)GO TO 2601
19500 IF(NWX.NE.1)GO TO 1486
19600 WRITE(JOUT,111)FNAME,FLNM,I,LIMIT,TF
19700 C********** BELOW IS FOR 'SECTIONS'
19800 1486 IF(KODE.NE.0)WRITE(JOUT,9150),KODE
19900 K=NWX-1
20000 IF(NWX.LE.1)GO TO 377
20100 IF(IT(J).NE.-3)WRITE(JOUT,3154),K,Y
20200 377 IF(IT(J).EQ.-3)WRITE(JOUT,5154),K,IBX,RINST(J)
20300
20400 2601 DO 602 K=1,NINS
20500 48 RIN=RINST(K)
20600 IF(NCNT(K,NUMPX).EQ.10000)GO TO 477
20700 IF(NWX.GT.1)GO TO 602
20800 477 NCNT(K,NUMPX)=1
20900 IJ=IPT(K,NUMPX)
21000 X=0
21100 IF(IJ.NE.0)X=ALL(JPT,IPT(K,NUMPX))
21200 C CHECK FOR "ALL" WITH RAND. DEV.
21300 CC IF(IJ.NE.0)X=V(IJ+2)
21400 WRITE(JOUT,5396),K,RIN,X
21500 X=DUR(K)
21600 IF(X.GT.10000.)GO TO 83
21700 WRITE(JOUT,8396),X
21800 GO TO 602
21900 5396 FORMAT(I3,') 'A4,' RANDOM TF =',F4.2,7X,'DURATION =',$)
22000 7396 FORMAT('+',F5.0,' NOTES')
22100 8396 FORMAT('+',F7.2,'"')
22200 83 X=X-10000.
22300 WRITE(JOUT,7396),X
22400 602 CONTINUE
22500 IF(MZ.EQ.0)GO TO 1601
22600 715 IF(IT3.NE.1.)GO TO 1602
22700 RA=T1*60.
22800 RB=T2*60.
22900 WRITE(JOUT,6154),RA,RB,TDUR
23000 IT3=0
23100 1602 IF(NWX.EQ.1)GO TO 315
23200 IF(IT(J).EQ.-3)GO TO 1108
23300 IT(J)=IT(J)/10
23400 GO TO 1108
23500 6154 FORMAT(' TMP=',F7.3,' TO',F8.3,
23600 1' DURING',F6.2,' SECS. BASIC TIME.'/)
23700 5154 FORMAT(/' << CHANGE',I3,' BEGINS ON NOTE',I4,1XA4,' >>'/)
23800 902 FORMAT(1XA4/)
23900 3154 FORMAT(/' << BASIC TIME OF CHANGE',I3,' IS',F8.3,'" >>'/)
24000 4154 FORMAT(' THE FIRST',F9.4,'" ARE OMITTED'/)
24100 315 IF(OP1.NE.0)WRITE(JOUT,4154),OP1
24200 1601 IF(NWX.GT.1) GO TO 1108
24300 IF(TF.GT.10.)TF=TF/60.
24400 TF=RNDOFF/TF
24500 C RNDOFF IS ROUND OFF NUMBER. (100 OR 1000)
24600 CROFF 100 HERE FOR NEW DAC!?#@&βX 1/76 TF=1000./TF
24700 DO 6015 K=3,NUMP
24800 COPYL(K)=-9900
24900 6015 COPY(K)=-9900.
25000 C INITS PARAM REPRESSION FEATURE.
25100 9926 DO 5015 K=1,NINS
25200 IQ(K)=BG(K)*10000.
25300 BG(K)=0
25400 RNP(K)=0
25500 P1(K)=0
25600 IF(DUR(K).LE.10000.)DUR(K)=DUR(K)-.0001
25700 C******* FEB. 16,71 FOR ROUND-OFF NONSENSE
25800 5015 KNT(K)=0
25900 CKL IF(MZ)WRITE(JOUT,1023),FNAME,IXIN,PLAY
26000 CKL IF(MX)WRITE(1,1023)FNAME,IXIN,PLAY
26100 IF(MZ)WRITE(JOUT,1023),FNAME,IXIN,PLAY,ISEMI
26200 IF(MX)WRITE(MDEV,1023)FNAME,IXIN,PLAY,ISEMI
26300 BW=0
26400 GO TO 500
26500
00100 1108 M=0
00200 JC=0
00300 CCHD=0
00400 C NWZZ IS SET AT 3111 IN SORTR. CCHD IS FOR CHORD FEATURE.
00500 CKL IF(NWZ)GO TO 1740
00600 IF(NWZ)GO TO 31
00700 DO 740 K=1,NWZZ
00800 X=BNW(K)
00900 IF(X-.0001.GT.BT)GO TO 2740
01000 IF(X.LE.BW)GO TO 2740
01100 IF(BW)GO TO 2740
01200 IT(J)=IT(J)*10
01300 NW=K
01400 GO TO 600
01500 2740 IF(X.LT.1000.)GO TO 740
01600 IF(X-J*10000.NE.KNT(J)+1.)GO TO 740
01700 X=BT+PR
01800 NW=K
01900 IBX=KNT(J)+1
02000 IT(J)=-3
02100 GO TO 600
02200 740 CONTINUE
02300 IT(J)=0
02400 31 KL=1
02500 2031 KNT(J)=KNT(J)+1
02600 ICT=KNT(J)
02700 C INSERT TRAP HERE FOR OVERLAP OF RESTARTED INSTS.******
02800 NPA=NP(J)
02900 PP1=P1(J)
03000 IF(BT.GE.DUR(J))GO TO 5174
03100 IF(IQ(J).EQ.0)GO TO 200
03200 P2=-IQ(J)/10000.
03300 IQ(J)=0
03400 KNT(J)=-1
03500 ICT=-1
03600 C PRINTS REST AND KNT=-1 WHEN 1ST BG TIME IS >0
03700 GO TO 4203
03800
03900 C IREST IS FLAG FOR RESTS
04000 200 IREST=0
04100
04200 203 DF=1.
04300 C DF=DUTY FACTOR
04400 DO 2155 L=2,NPA
04500 ISUB=0
04600 C WHY DOES ISUB APPEAR AT 14700/5?
04700 IDF=0
04800 C IDF IS DUTY FACTOR FLAG
04900 IJ=IPT(J,L)
05000 3024 IF(IJ)IJ=JPT(-IJ)
05100 IF(IJ)GO TO 3024
05200 C FOLLOWS UP ON POINTERS TO POINTERS!
05300 PM=1.
05400 IF(IJ.GT.1)GO TO 2157
05500 P(L)=0
05600 GO TO 3207
05700 2157 LN=IJ+2
05800 NM=ABS(V(IJ-1))+LN-4
05900 NL=V(IJ)
06000 IF(NL.GT.-100)GO TO 272
06100 IF(NL.GT.-200)GO TO 372
06200 ISUB=-1
06300 NL=NL+200
06400 C FOR SUBROUTINE FLAG
06500 372 IF(NL.GT.-100)GO TO 272
06600 IDF=-1
06700 NL=NL+100
06800 C DEC.6,72 FINDS DUTY FACTOR PARAM
06900 272 VIJ2=PARAM(V(IJ+1),KN)
07000 C A PARAM NUM CAN APPEAR ANYWHERE A NORMAL NUM IS EXPECTED.
07100 KIJ2=VIJ2
07200 KN=NL/(-11)
07300 IF(KN.EQ.0)GO TO 1100
07400 GO TO (61,62,62,62,65,65,67,68),KN
07500
07600 1100 IF(KIJ2.EQ.1)GO TO 1200
07700 ML=3
07800 1900 KA=1
07900 VX1=0
08000 DO 1156 K=LN,NM,ML
08100 X=PARAM(V(K),X)
08200 C NOW % NUM MAY BE A PARAM. (E.G. P22 1,2 ETC.) X IS DUMMY ARG.
08300 VX(KA+1)=X+VX(KA)
08400 1156 KA=KA+1
08500 X=RAN(X)
08600
08700 DO 1157 K=2,21
08800 C LIMIT OF 20 DIFF. %'S OF RAN. SELECTION ON 2 POSSIBLE LINES.
08900 IF(X.GT.VX(K))GO TO 1157
09000 KL=K-1
09100 IF(KN.EQ.7)GO TO 6157
09200 GO TO 1400
09300 1157 CONTINUE
09400
09500 1400 LN=IJ+3*KL
09600 1462 RA=PARAM(V(LN),K)
09700 IF(RA.EQ.-10000.)GO TO 4174
09800 C FOR "FINE" IN RLIST
09900 RB=PARAM(V(LN+1),K)
10000 C FUNCTION PARAM CHECKS TO SEE IF WE SHOULD LOOK AT ANOTHER PARAMETER FOR DATA.
10100 PAR=RAND(RA,RB)
10200 1300 IF(NL.EQ.-1)GO TO 1155
10300 PAR=IFIX(PAR)
10400 PM=2.
10500 C IF 2 THEN PRINTS A4
10600 IF(PAR.GE.199.)IREST=-1
10700 GO TO 1155
10800 1200 PAR=PARAM(V(IJ+2),PAR)
10900 CHECKS IF REFERING TO OTHER PARAM.
11000 GO TO 1300
11100
11200 C NEXT IS FOR SUBROUTINE AND QUAD CALLS
11300 61 IF(NL.LT.-12)GO TO 6100
11400 601 IF(AMOD(V(IJ),1.0).EQ.0)GO TO 871
11500 C FOUND 'MICRO'
11600 CALL MICRO
11700 GO TO 3208
11800 871 X=P2
11900 CALL SUBR
12000 CC 7/74 NOW SET DUR(J) =0 IN SUBR IF(DF)GO TO 5174
12100 C* OUT--COLGATE DF=-1 IN 'SUBR' WILL CAUSE 'END' FOR INST.
12200 IF(L.EQ.2)GO TO 4203
12300 IF(X.EQ.P2)GO TO 3208
12400 PP2=P2
12500 PR=P2
12600 GO TO 3208
12700 C ABOVE IS FOR P2 CHANGES IN SUBROUTINE
12800 C TF,TEMPO,CONDUCT WILL AFFECT P2 ONLY WHEN P2 CALLS THE SUBR.,
12900 C ALL 'TEMPO' CHANGES WILL BE IGNORED!! (THEN DUR. IN SECS. MUST
13000 C BE SET TO 'REAL TIME'.)
13100 6100 COFF1(J)=PARAM(V(LN),X)
13200 C FOR 'CUTOFF N1, N2' N1=CUTOFF TIME, N2=SHORTEST NOTE.
13300 COFF2(J)=PARAM(V(LN+1),X)
13400 GO TO 2155
13500
13600 C FOLLOWING IS FOR STRINGS OF VALUES.
13700 62 KL=NCNT(J,L)+1
13800 IF(KL.GT.KIJ2)KL=1
13900 IF(NL.EQ.-46)GO TO 677
14000 IF(NL.NE.-36)GO TO 162
14100 C THIS PART FOR STRINGS OF RAND SELECTION
14200 677 LN=KL+IJ+1
14300 KL=KL+1
14400 IF(KL.GT.KIJ2)KL=1
14500 NL=NL+45
14600 C FOR NUMBERS ONLY SO FAR(THIS MAKES NL=-1. FOR NOTES, =9)
14700 162 NCNT(J,L)=KL
14800 IF(NL.GT.-22)GO TO 1462
14900 C JUMP RAND SELECTION
15000 PAR=PARAM(V(IJ+KL+1),K)
15100 IF(K.NE.0)GO TO 1155
15200 C JUMP IF REFERING TO ANOTHER PARAM. (I.E. K NOT = 0)
15300 IF(KN.NE.3)GO TO 1155
15400 IF(PAR.EQ.-10000.)GO TO 4174
15500 PM=2.
15600 IF(PAR.GT.300.)GO TO 777
15700 IF(PAR.GE.1.)GO TO 877
15800 IF(NL.NE.-33)GO TO 777
15900 C NEXT FOR CHORD FEATURE
16000 PAR=-PAR
16100 CCHD=ABS(V(IJ+KL+2))
16200 KL=KL+1
16300 IF(KL.GT.KIJ2)KL=1
16400 NCNT(J,L)=KL
16500 JCHD=IJ
16600 LCHD=L
16700 GO TO 877
16800 777 PM=3.
16900 877 IF(PAR.EQ.199.)IREST=-1
17000 GO TO 5155
17100
17200 65 W=-9900.-V(IJ-3)
17300 C W=BG TIME OF MOVE.
17400 X=ABS(V(IJ-1))
17500 IF(NL.EQ.-56)GO TO 977
17600 IF(NL.NE.-58)GO TO 771
17700 977 PM=2.
17800 771 Z=(BT-W)/VIJ2
17900 C Z= % OF WAY THROUGH.
18000 IF(Z.GT.1.)Z=1.
18100 Y=PARAM(V(LN),Y)
18200 IX=3
18300 IF(X.EQ.7)IX=4
18400 W=PARAM(V(IJ+IX),W)
18500 IF(NL.LT.-58)GO TO 3205
18600 PAR=(W-Y)*Z+Y
18700 IF(X.EQ.7.)GO TO 1600
18800 GO TO 255
18900 C FOR "MOVX"
19000 C THE .01 IS NEEDED FOR MOVE TO OR FROM 0.
19100 3205 PAR=RMOVX(W,Y,Z)
19200 C SEE FUNCTION RMOVX 6/74 -- CAN'T HAVE -20→+20, ETC., -20→-40 OK.
19300 C THIS NEEDS WORK!
19400 IF(X.NE.7.)GO TO 255
19500 W=PARAM(V(IJ+5),W)
19600 Y=PARAM(V(IJ+3),Y)
19700 X=RMOVX(W,Y,Z)
19800 GO TO 3206
19900 C NEXT IS FOR MOVING RAND RANGES.
20000 1600 W=PARAM(V(IJ+3),W)
20100 C*********** BACK TO 65 IS NEW. FEB. 15,71
20200 X=(PARAM(V(IJ+5),X)-W)*Z+W
20300 3206 PAR=RAND(PAR,X)
20400 255 IF(PAR.GT.-19999.0)GO TO 155
20500 PAR=PARAM(PAR+10000.,Y)
20600 C THIS FOR MOVP -- THE NUMS. ARE E.G. -19999.12, -19999.129
20700 GO TO 155
20800
20900 67 LN=IJ+3
21000 NM=LN+KIJ2-1
21100 ML=1
21200 GO TO 1900
21300
21400 C 7/74 **** NOTE PROBLEMS OF P2 WITH SUBR, TEMPO, TF AND RAND. TF.
21500 C ALSO DF. THE REAL TIME VALUE PRINTED MAY HAVE GONE THROUGH MANY
21600 C CHANGES. HENCE WHEN TRANSFERING THE VALUE TO OTHER PARAMS OR
21700 C INSTS GREAT CARE MUST BE TAKEN TO BE SURE THE RESULTS ARE CORRECT.
21800 6157 LN=V(LN-1)
21900 DO 1068 K=1,KL
22000 1068 IF(K.LT.KL)LN=LN+V(LN)+1
22100 2068 PM=LN+1
22200 PAR=LN+V(LN)
22300 IF(PM.EQ.2)PAR=IFIX(PAR)
22400 GO TO 5155
22500
22600 68 KL=NCNT(J,L)
22700 IF(NL.NE.-1000)GO TO 680
22800
22900 IF(CCHD.GE.0)GO TO 2155
23000 IF(NPA.LT.3)NPA=3
23100 C NPA CAN =2 IN SOME CASES, THEN THE NEW CHORD NOTE WOULDN'T PRINT.
23200 CCHD=0
23300 KL=NCNT(J,LCHD)+1
23400 X=V(JCHD+KL)
23500 CKL IF(X.GE.0)GO TO 9203
23600 IF(X.GE.0)GO TO 1170
23700 NCNT(J,LCHD)=KL
23800 CCHD=ABS(V(JCHD+KL+1))
23900 CKL GO TO 9203
24000 GO TO 1170
24100 680 IF(KL.EQ.0)GO TO 774
24200 IF(KL.NE.10000)GO TO 773
24300 774 KL=KIJ2
24400 773 PM=KL+1
24500 PAR=PM+V(KL)-1
24600 KL=PAR+1
24700 IF(V(KL).NE.-10000.)GO TO 6174
24800 KNT(J)=KNT(J)-1
24900 DUR(J)=BT
25000 C 'END' OR 'FINE' IN 'LIT' LIST.
25100 6174 IF(V(KL).EQ.999.)KL=IJ+2
25200 NCNT(J,L)=KL
25300 GO TO 5155
25400
25500 155 IF(PM.EQ.2)PAR=IFIX(PAR)
25600 C GETS RID OF UNWANTED DECIMALS
25700 1155 IF(PAR.EQ.-10000.)GO TO 4174
25800 C TYPE 'END' OR 'FINE' AS LAST IN ANY STRING TO SET DURATION.
25900 5155 P(L)=PAR
26000 3207 PL(L)=PM
26100 IF(ISUB)GO TO 601
26200 IF(L.EQ.2)GO TO 4203
26300 3208 IF(IDF.GE.0)GO TO 2155
26400 DF=PAR
26500 C DUTY FAC. IS ALWAYS % OF P2 - WHETHER CONSIDERING BASIC OR REAL TIME.
26600 IDF=0
26700 2155 CONTINUE
26800 GO TO 1170
26900
27000 4203 X=COFF1(J)
27100 IF(X.EQ.0)GO TO 6102
27200 IF(X.LT.0)GO TO 1102
27300 IF(X.LE.BT)GO TO 6102
27400 C FOR 'CUTOFF N1, N2' N1=CUTOFF TIME, N2=SHORTEST NOTE.
27500 C JUMP IF 'TEMPO' CHANGE
27600 1102 IF(BT+X.LT.0)GO TO 6102
27700 Y=COFF2(J)
27800 IF(BT.GE.Y)GO TO 6102
27900 C -N1,N2 CAUSES REST FROM AFTER N1 UP TO N2.
28000 P2=BT-Y
28100 C IF COFF2 IS NEG. THEN WE GET A REST UP TO THAT BASIC TIME.
28200 GO TO 6102
28300 102 IF(BT+P2.GT.X-COFF2(J))P2=X-BT
28400 6102 PR=P2
28500 PX2=P2
28600 C TO SAVE THE UNPROCESSED P2 FOR 'P2 P2;' IN INPUT. 7/74
28700 IF(T5.EQ.0)GO TO 7203
28800 IF(IT3.LE.1)GO TO 6203
28900 IF(BT.LT.TBG+TDUR)GO TO 6203
29000 3155 IT3=IT3+3
29100 TBG=TBG+TDUR
29200 TDUR=V(IT3)
29300 IF(BT.GE.TBG+TDUR)GO TO 3155
29400 T1=V(IT3+1)
29500 T2=V(IT3+2)
29600 CALL SQYY(AC,T1,T2,TDUR)
29700 6203 RA=PR
29800 IF(BT.EQ.TBG)XT(J)=T1
29900 K=IT3
30000 RC=0
30100 KA=1
30200 Z=TDUR+TBG-BT
30300 X=T1
30400 Y=T2
30500 YY=AC
30600 CHN=TBG
30700 ZZ=TDUR
30800 CALL ACCEL
30900 8203 P2=RA*RD
31000 7203 P2=P2*T4
31100 X=ABS(P2*TF)
31200 C P2 IS KEPT WITHOUT TF*
31300 K=X+.5
31400 Y=ROFF(J)
31500 Y=Y+K-X
31600 IF(ABS(Y).LT.1.)GO TO 7155
31700 X=1
31800 IF(Y)X=-X
31900 K=K-X
32000 Y=Y-X
32100
32200 C ROUND-OFF GAP WILL NOT EXCEED .001****.01 WITH NEW DAC!X?#@(MUS10)
32300 C*********** FEB 17,71
32400 7155 IF(P2.NE.0)GO TO 4171
32500 WRITE(NDEV,4171)RINST(J),P1(J)
32600 IREST=-1
32700 4171 FORMAT(/' ******** WARNING: P2 = 0 ******* ',A4,F)
32800 IF(P2)K=-K
32900 PP2=K/RNDOFF
33000 ROFF(J)=Y
33100 C AVOIDS ROUND-OFF PROBLEMS **** TO 1/100 (1/76)
33200 C AFTER ALL THIS P2 IN SUBR MAY NOT EQUAL PP2(REAL TIME) DF COMES LATER!
33300
33400
33500 C NEVER MORE THAN .1( DEVIATION WITH RAN TF. (RTF=.05)
33600
33700 CKL6155 IF(ICT)GO TO 9203
33800 6155 IF(ICT)GO TO 1170
33900 GO TO 2155
34000
34100 1170 IF(BT.NE.0)GO TO 577
34200 IF(J.EQ.1)GO TO 303
34300 577 IF(IPT(J,1).EQ.0)GO TO 303
34400 C NEXT FOR 'RR' = RANDOM RESTS
34500 X=ALL(JPT,IPT(J,1))
34600 Y=RAN(Y)
34700 C ABOVE IS SAME AS RAND(0.0, 1.0)
34800 IF(Y-X)IREST=-1
34900 303 IF(IPT(J,NUMPX).EQ.0)GO TO 2303
35000 C 'RD' = RANDOM DEVIATION. THIS BECOMES P31. IT CAN READ ANOTHER P NUM.
35100 C NUMPX=NUMB. OF PARAMS +1
35200 IF(ICT)GO TO 2303
35300 X=ALL(JPT,IPT(J,NUMPX))/2.
35400 IF(PP2.GE.0)GO TO 615
35500 IREST=-1
35600 PP2=-PP2
35700 615 Y=IFIX(RAND(-X,X)*RNDOFF+.5)/RNDOFF
35800 C ROUNDS TO 1/100 OR 1/1000 -- RNDOFF
35900 W=RDEV(J)
36000 IF(ABS(W+Y).GT.X)Y=-Y
36100 C TOTAL RAND DEV.(RDEV) WON'T EXCEED P100
36200 RDEV(J)=W+Y
36300 PP2=PP2+Y
36400 C SET P100 TO .0001 TO BRING VOICE BACK TO EXACT TIME(0 WON'T DO IT)
36500
36600 2303 IF(IREST)GO TO 2022
36700 IF(PP2)GO TO 2022
36800
36900 ZPAR=PP1
37000 P1(J)=PP1+PP2
37100 C ZPAR IS USED HERE WHEN OP1(OMIT) IS .GT.0. OMIT IS IN REAL TIME.
37200 RIN=RINST(J)
37300 2021 IF(PP1.LT.OP1)GO TO 2612
37400 IF(INVIS(J).LT.0)GO TO 2170
37500 C ALL PARAMS WILL PRINT,1ST TIME WHEN USING 'OMIT'.
37600 IF(INONLY.GT.0)GO TO 1204
37700 4021 IF(P(NPA).NE.COPY(NPA))GO TO 5021
37800 IF(PL(NPA).NE.COPYL(NPA))GO TO 5021
37900 IF(PL(NPA).GT.2)GO TO 5021
38000 C 'LIT' DATA WILL ALWAYS PRINT BUT NOT NOTES OR FUNCS.
38100 NPA=NPA-1
38200 IF(NPA.GT.2)GO TO 4021
38300 5021 DO 1304 K=3,NPA
38400 COPYL(K)=PL(K)
38500 1304 COPY(K)=P(K)
38600 1204 IF(PL4.NE.1)GO TO 2170
38700 P4=P4*AMPFAC
38800 W=0
38900 RNP(J)=P4
39000 DO 1021 K=1,NINS
39100 1021 IF(P1(K).GT.PP1)W=W+RNP(K)
39200 IF(W-RAMP.LE.0)GO TO 2170
39300 RAMP=W
39400 AMPTIM=PP1
39500 2170 IF(MX.EQ.3)GO TO 2612
39600 PP1=PP1-OP1
39700 C PUTS SPACES BETWEEN NOTES .GT. .05( APART
39800 IF(MZ.NE.-1)GO TO 5170
39900 IF(A.GE.PP1)GO TO 5170
40000 IF(INONLY)WRITE(JOUT,902)
40100 A=PP1+.05
40200 5170 ML=NPRLN
40300 IF(NPA.LT.NPRLN)ML=NPA
40400 MLX=3
40500 NL=2
40600 IEND=0
40700 K=INVIS(J)
40800 IF(K.EQ.0)GO TO 3170
40900 IF(K.EQ.-1)GO TO 9170
41000 IEND=-1
41100 C THIS DELETES END PRINTOUT ( ;PRINT P1 ETC.)
41200 IF(K.EQ.-2)GO TO 3170
41300 C -1=INVIS FRONT, -2=INVIS END -3=BOTH
41400 9170 RIN=0
41500 C NEEDED TO INIT INVISIBLE MODE PRINT-OUT (NO INST NAME, P1, P2)
41600 C NEXT CREATES FORMAT DATA IN IFM ARRAY.
41700 3029 KL=3
41800 GO TO 4170
41900 3170 IF(J.EQ.INONLY)GO TO 775
42000 IF(.NOT.INONLY)GO TO 2612
42100 775 VX(1)=PP1
42200 IF(IPT(J,NUMPY).EQ.0)GO TO 1303
42300 C NUMPY=NUMP+2
42400 DF=ALL(JPT,IPT(J,NUMPY))
42500 C FOR 'DF'=DUTY FACTOR. A SINGLE NUM. OR READ A PARAM. (NO TEMPO AFFECT.)
42600 1303 IF(DF.GT.0)GO TO 6170
42700 VX2=PP2+DF
42800 IF(VX2.LE.0)VX2=PP2/2
42900 C NO NEG. TIME VALUES ALLOWED.
43000 C NEG. DF= FIXED REST AREA BEFORE NEXT ATTACK.
43100 GO TO 7170
43200 6170 IF(DF.LT.100)GO TO 8170
43300 C DF+100=FIXED NOTE DUR. NOT.GT.PP2 7/74 COLGATE -AND BELOW
43400 C DF+1000=FIXED TIME OF OVERLAP 3/77 (CHNG THIS TO 300 SOMEDAY!)
43500 IF(DF.GT.1000)GO TO 8171
43600 VX2=DF-100.
43700 IF(VX2.GT.PP2)VX2=PP2
43800 C DF+200= FIXED DURATION WITHOUT REGARD TO OVERLAPS
43900 IF(DF.GT.200)VX2=DF-200.
44000 GO TO 7170
44100 C*** NEXT FOR DF>1000 ****!!!! SWITCH THIS FEATURE WITH ORD. DF SOMEDAY!!!!
44200 8171 VX2=PP2+DF-1000.
44300 GO TO 7170
44400 8170 VX2=PP2*DF
44500 7170 FRM3=B2A
44600 FRM4=B2B
44700 KL=5
44800 IF(NPA.LT.3)GO TO 2121
44900
45000 4170 NL=2
45100 DO 1121 K=MLX,ML
45200 X=P(K)
45300 L=PL(K)
45400 IF(L-2)321,521,621
45500 C L=1 NUMBS, =2 NOTES,FUNCS, =3 LITS.
45600 321 IF(X.GE.0)GO TO 4211
45700 FRM(KL)=COMMA
45800 NL=NL+1
45900 KL=KL+1
46000 4211 FRM(KL)=B8
46100 IF(ABS(X).GE.1000.0)FRM(KL)=B9
46200 FRM(KL+1)=BCOM
46300 KL=KL+1
46400 NL=NL+1
46500 421 VX(KL-NL)=X
46600 GO TO 1121
46700 521 LN=X
46800 IF(LN.LT.200)GO TO 2621
46900 LN=LN-200
47000 IF(LN.LT.10)IVX=IF0+LN*2
47100 IF(LN.GE.10)IVX=IF10 + 256*(LN/10) + 2*MOD(LN,10)
47200 C FOR FUNC NUMS. CAN NOW BE F0→F99. (RVX AND RVX ARE EQUIV.)
47300 GO TO 1621
47400 2621 KA=LN-1
47500 IOCT=1+KA/12
47600 LN=MOD(KA,12)+1
47700 IVX=ISC(LN)+IOC(IOCT)
47800 1621 VX(KL-NL)=RVX
47900 GO TO 42
48000 621 IF(L.GT.3)GO TO 721
48100 VX(KL-NL)=X
48200 C ABOVE LETS A4 WD BE USED IN SUBR BY SETTING IPL(N)=3.
48300 42 FRM(KL)=BA4
48400 KL=KL+1
48500 NL=NL+1
48600 FRM(KL)=BCOM
48700 C CREATES '1XA4,'
48800 GO TO 1121
48900 721 LN=X
49000 FRM(KL)=B1X
49100 NL=NL+1
49200 DO 821 M=1,LN-L+1
49300 C FOR 'LIT' STRINGS
49400 KL=KL+1
49500 VX(KL-NL)=V(L-1+M)
49600 821 FRM(KL)=BA1
49700 1121 KL=KL+1
49800
49900 C NO MORE THAN 80 ITEMS IN FORMAT.
50000 2121 IF(KL.LE.80)GO TO 21211
50100 21212 FORMAT(' ERROR! TOO MANY LIT. ITEMS')
50200 WRITE(NDEV,21212)
50300 21211 DO 921 M=KL+1,80
50400 921 FRM(M)=BLA
50500 FRM(KL)=BPRN
50600
50700 1921 L=KL-NL-1
50800 IF(MX)WRITE(MDEV,FRM)RIN,(VX(K),K=1,L)
50900 IF(MZ.GE.0)GO TO 3023
51000 IF(ML.GE.NPA)FRM(KL)=BDOL
51100 WRITE(JOUT,FRM),RIN,(VX(K),K=1,L)
51200 3023 IF(ML.GE.NPA)GO TO 3021
51300 MLX=ML+1
51400 ML=ML+NPRLN
51500 IF(ML.GT.NPA)ML=NPA
51600 RIN=BLA
51700 GO TO 3029
51800 3021 IF(IEND)GO TO 3011
51900 C IEND=-1 FOR INVIS. ENDING. (ALLOWS EXTENTION OF P LIST.)
52000 IF(MX)WRITE(MDEV,3616)RINST(J),ICT
52100 3011 IF(MZ)WRITE(JOUT,8902),J,RINST(J),ICT,BT
52200 2612 PP1=ZPAR
52300 GO TO 21
52400 8902 FORMAT('+;<'I2,1XA4,I4,' >',F7.2)
52500 3616 FORMAT('; < ',A4,I4)
52600 CC3616 FORMAT(';PRINT P1;< ',A4,I4)
52700 C PRINTS RESTS
52800 2022 PP2=ABS(PP2)
52900 C IN THIS VERSION TYPE 'R' FOR RESTS IN ANY PARAM BUT P2.
53000 C FOR RESTS IN SEQS. TYPE -DUR.
53100 C WHEN RANDOM RESTS ARE CHOSEN, SEQS. MISS NOTES.
53200 C RAN RESTS ARE TOUCHED BY SUBROUTINES ONLY BY SETTING IREST!!
53300 RNP(J)=0
53400 P1(J)=PP1+PP2
53500 C STORES NEXT P1 TIME FOR THIS INST.
53600 IF((MZ.NE.-1).OR.(PP1.LT.OP1))GO TO 21
53700 X=PP1-OP1
53800 IF(A.GE.X)GO TO 121
53900 WRITE(JOUT,902)
54000 A=X+.05
54100 C NEXT PRINTS A REST INDICATION
54200 121 IF(INONLY.OR.J.EQ.INONLY)WRITE(JOUT,1110),RINST(J),X,PP2,
54300 1 J,RINST(J),ICT,BT
54400 21 IF(CCHD.EQ.0)GO TO 122
54500 C NEXT FOR CHORDS
54600 P3=CCHD
54700 L=LCHD
54800 NL=-1000
54900 CCHD=-CCHD
55000 IJ=JCHD
55100 GO TO 68
55200 4174 KNT(J)=KNT(J)-1
55300 C TO GET PROPER NOTE COUNT AFTER 'FINE' WAS FOUND.
55400 GO TO 5174
55500 122 PR=ABS(PR)
55600 BG(J)=BT+PR
55700 IF(ICT.EQ.DUR(J)-10000.)GO TO 5174
55800 IF(BG(J).LT.DUR(J))GO TO 500
55900 5174 BG(J)=19999.
56000 DO 3174 K=1,NINS
56100 C INSERTS CAN'T FOLLOW LAST REGULAR NOTE.
56200 C (ADD REST IF INSERT AT END IS NEEDED.)
56300 3174 IF(BG(K).LT.19999.)GO TO 500
56400 GO TO 175
56500 C CHOOSES INST WITH NEXT BEGIN TIME.
56600 500 J=1
56700 BW=BT
56800 NL=NINS
56900 DO 22 K=2,NL
57000 22 IF(BG(J).GT.BG(K))J=K
57100 IF(J.GT.NINS.OR.NINS.EQ.1)GO TO 3022
57200 J=1
57300 DO 5022 K=2,NINS
57400 X=P1(J)
57500 Y=P1(K)+.0001
57600 C LOWEST NUMBERED INST WILL COME 1ST IF BG TIMES ARE VERY CLOSE
57700 IF(BG(J).EQ.19999.)X=19999.
57800 IF(BG(K).EQ.19999.)Y=19999.
57900 5022 IF(X.GT.Y)J=K
58000 C ABOVE IS FOR ROUND-OFF PROBLEMS WITH 'TEMPO' AND 'CONDUCT'.
58100 3022 BT=BG(J)
58200 IF((BT.EQ.19999.).OR.(P1(J).GE.DURX))GO TO 175
58300 IF(KNT(J).GT.0)GO TO 1022
58400 IF(KNT(J).EQ.0)P1(J)=0
58500 IF(KNT(J).EQ.-1)KNT(J)=0
58600 C N.B. 'TF' CONTROLS BG TIME WHEN BG .GT. 0
58700 1022 IF((BT.LT.T6).OR.(IT3.GT.1))GO TO 1108
58800 T4=T2
58900 T5=0
59000 T6=10000.
59100 GO TO 1108
59200 1175 FORMAT('+',A4,'=',F7.2,'"',I4,' NTS.',4X,$)
59300 C*1175 FORMAT('+',A5,'=',F7.2,3X,$)
59400 1109 FORMAT(' FINISH; < ',A4,'.DAT'/)
59500 1110 FORMAT(' <',A4,2F8.2,2X,'******* REST <'I2,1XA4,I4,F11.2)
59600 1603 FORMAT(' AMPL. FACTOR=',F5.2,', P4 MAX.AMP.=',F9.2,', AT TIME='
59700 1,F8.3)
59800 175 IF(MZ)WRITE(JOUT,1109),FNAME
59900 IF(MX.GE.0)GO TO 4175
60000 WRITE(MDEV,1109),FNAME
60100 CC END FILE 1
60200 WRITE(NDEV,604 )
60300 604 FORMAT(/' ***** DATA HAS BEEN WRITTEN ON DISK *****'/)
60400 603 FORMAT(' TOTAL DURS: ',$)
60500 4175 WRITE(JOUT,1603),AMPFAC,RAMP,AMPTIM
60600 WRITE(JOUT,603)
60700
60800 5175 IJ=0
60900 Y=0
61000 DO 2175 K=1,NINS
61100 X=P1(K)-OP1
61200 IF(X.GT.Y)Y=X
61300 J=KNT(K)
61400 IJ=IJ+J
61500 6175 WRITE(JOUT,1175),RINST(K),X,J
61600 2175 CONTINUE
61700 IF(NINS.GT.1)WRITE(JOUT,8175)IJ,Y
61800
61900 8175 FORMAT(/' TOTAL NOTES =',I5,F8.2,'"')
62000
62100 3175 WRITE(NDEV,1023)FNAME,IXIN
62200 CALL EXIT
62300 END